Shareware Grab Bag/Shareware Grab Bag.iso/050/bix01.arc/COMMON.LIB

Text File | 1986-07-07 | 10KB | 409 lines

             {  Program Name   : Common.lib                         }
             {  Date Begun     : 10/01/1985                         }
             {  Last Update    : 01/06/1986                         }

             {  Programmer     : Robert L. Hume                     }

             {  Copyright      : Robert L. Hume                     }
             {                 : All rights Reserved                }

             {  Language       : Pascal                             }
             {  Implementation : Borland Turbo Pascal Compiler      }

Procedure SwitchVar{**(var Arg1,Arg2; Size:Integer)**};
  type Scratch  = Array[1..MaxInt] of Byte;
   var count : Integer;
       Tmp : Byte;
       A1  : Scratch absolute Arg1;
       A2  : Scratch absolute Arg2;
  begin
    for count:=1 to Size do
      begin
        Tmp:=A1[count];
        A1[count]:=A2[count];
        A2[count]:=Tmp;
      end;
  end;
  { ** SwitchVar ** }

Function Intpower{**(number,exponent:Integer):integer **};
  var value,i : Integer;
  Begin
    value:=1;
    for i:=1 to exponent do
      value:=value * number;
    Intpower:=value;
  End;
  { ** Intpower ** }

Procedure Wait;
  Begin
    Delay(Wait_Duration);
  End;
  { ** Wait ** }

Function KeyWait{**:Byte **};
  var KeyStroke : Regrec;
  Begin
    Flush_Keyboard;
    While not Keypressed do
      Lock_Detect;
    KeyStroke.ax:=0;
    intr($16,KeyStroke);
    KeyWait:=Lo(KeyStroke.ax);
    Flush_Keyboard;
  End;
  { ** KeyWait ** }

Procedure Set_Cursor{**(c:Byte)**};
  var r: RegRec;
  Begin
    r.ax:=$100;
    if (c=0)
      then r.cx:=-$0800
      else r.cx:=((13-c) shl 8) or 12;
    intr($10,r);
  End;
  { ** Set_Cursor ** }

Procedure WhereScr{**(var x,y: Byte)**};
  var r: RegRec;
  Begin
    r.ax:= $0300;
    r.bx:= 0;
    intr($10,r);
    x:= succ(r.dx and $ff);
    y:= succ(r.dx shr 8)
  End;
  { ** WhereScr ** }

Procedure Flush_keyboard;
  var Ch : Char;
  Begin
    While keypressed do
      Read(kbd,Ch);
  End;
  { ** Flush_keyboard ** }

Function SaveKbd{**:Byte **};
  var LockStat : Byte absolute Lock_Status;
  Begin
    SaveKbd:=LockStat;
  End;
  { ** SaveKbd ** }

Procedure SetKbd{**(Status:Byte)**};
  var  LockStat : Byte absolute Lock_Status;
  Begin
    LockStat:=Status;
    Lock_Detect;
  End;
  { ** SetLock ** }

Procedure Lock_Detect;
  const  Blank = '   ';

    function LockFlag : Byte;
      begin
        LockFlag:=(Lock_Status and  1) +
                  (Lock_Status and  2) +
                  (Lock_Status and 32) +
                  (Lock_Status and 64);
      end;

    procedure Num_Lock;
      begin
        WriteAt(74,21,h,'[N]');
      end; { Num_Lock }

    procedure Caps_Lock;
      begin
        WriteAt(74,22,h,'[C]');
      end; { Caps_Lock }

    procedure Neither;
      begin
        WriteAt(74,21,n,Blank);
        WriteAt(74,22,n,Blank);
      end;

  Begin
    Case LockFlag of
       1,2,96 : begin
                  Num_Lock;
                  Caps_Lock;
                end;
     33,34,64 : begin
                  Caps_Lock;
                  WriteAt(74,21,n,Blank);
                end;
     32,65,66 : begin
                 Num_Lock;
                 WriteAt(74,22,n,Blank);
               end;
      else
        Neither;
    end;
  End;
  { ** Lock_Detect ** }

Function Stringof{**(ascii,len:Byte) AnyStr **};
  var count : Byte;
      TmpStr : AnyStr;
  Begin
    FillChar(TmpStr,(len+1),chr(ascii));
    TmpStr:=Copy(TmpStr,1,len);
    Stringof:=TmpStr;
  End;
  { ** Stringof ** }

Procedure Whichline{**(LineType:Byte;
          var hl,vl,tl,tr,bl,br,lj,rj,tj,bj,isect:Byte)**};
  Begin
    Case LineType of
      1 : begin
            hl:=196; vl:=179;
            tl:=218; tr:=191;
            bl:=192; br:=217;
            lj:=195; rj:=180;
            tj:=194; bj:=193;
            isect:=197;
          end;
      2 : begin
            hl:=205; vl:=186;
            tl:=201; tr:=187;
            bl:=200; br:=188;
            lj:=204; rj:=185;
            tj:=203; bj:=202;
            isect:=206;
          end;
    end;
  End;
  { ** Whichline ** }

Procedure VLine{**(col,row,ascii,limit:Byte)**};
  var count : Byte;
  Begin
    GotoXY(col,row);
    for count:=1 to limit do
      Begin
        Write(chr(ascii));
        GotoXY(WhereX-1,WhereY+1);
      End;
  End;
  { ** VLine ** }

Procedure Highlight{**(s:AnyStr)**};
  Begin
    NormVideo;
    Write(s);
    LowVideo;
  End;
  { ** Highlight ** }

Procedure Dim{**(s:AnyStr)**};
  Begin
    LowVideo;
    Write(s);
    NormVideo;
  End;
  { ** Dim ** }

Procedure WriteAt{**(col,row:Byte;Attrib:DspAtt;s:AnyStr)**};
  var Attribute,x,y,pos : Byte;
      WhichScr,TmpOffs : Integer;

    function CalcOffset : Integer;
      begin
        GotoXY(col,row);
        x:=WhereX; y:=WhereY;
        WhereScr(x,y);
        CalcOffset:=(pred(y)*SByteWidth)+((pred(x) shl 1));
      end;

    procedure SetAttribute;
      begin
        Case ord(Attrib) of
          0 : Attribute:=NormVid;
          1 : Attribute:=BrtVid;
          2 : Attribute:=RevVid;
          3 : Attribute:=BrBlVid;
          4 : Attribute:=UlineVid;
        end;
      end;

    procedure Display;
      begin
        TmpOffs:=CalcOffset;
        for pos:=1 to length(s) do
          begin
            Screen[TmpOffs]:=ord(s[pos]);
            Screen[TmpOffs+1]:=Attribute;
            TmpOffs:=TmpOffs+2;
          end;
        GotoXY(col+pos,row);
      end;

    procedure VDisplay;
      begin
        x:=(col shl 1)-1;
        for pos:=1 to length(s) do
          begin
            VirScr[WhichScr]^.VirtImage[row,x]:=ord(s[pos]);
            VirScr[WhichScr]^.VirtImage[row,x+1]:=Attribute;
            x:=x+2;
          end;
      end;

  Begin
    SetAttribute;
    if col=0
      then col:=((Width shr 1)-(length(s) shr 1));   { Center if col=0 }
    WhichScr:=trunc(row/100);
    row:=(row mod 100);                              { Select Screen   }
    if WhichScr=0
      then Display
      else VDisplay;
  End;
  { ** WriteAt ** }

Function FKeyResp{**(Lowlmt,Uplmt:Byte):Byte **};
  var KeyStroke : Regrec;
  Begin
    Flush_Keyboard;
    Repeat
      KeyStroke.ax:=0;
      intr($16,KeyStroke);
    Until Hi(KeyStroke.ax) in [Lowlmt..Uplmt];
    FKeyResp:=Hi(KeyStroke.ax);
    Flush_Keyboard;
  End;
  { ** FKeyResp ** }

Procedure NumInput{**( col,row,len : Byte;
                      HiLo : DspAtt;
                      var ReturnStr : AnyStr)**};

  var  pos,Lock,Key  : Byte;
       decimal       : Boolean;
       Resp          : Char;

    procedure SetUp;
      begin
        pos:=0; decimal:=false;
        ReturnStr:=Stringof(NumerPrmt,len);
        WriteAt(col,row,h,ReturnStr);
      end;

    procedure Add_Next;
      begin
        Delete(ReturnStr,1,1);
        Insert(Resp,ReturnStr,len);
        WriteAt(col,row,h,ReturnStr);
      end;

   procedure Exit;
     begin
       pos:=1;
       While ReturnStr[pos]=chr(NumerPrmt) do
         begin
           Delete(ReturnStr,pos,1);
           Insert(' ',ReturnStr,pos);
           pos:=pos+1;
         end;
       WriteAt(col,row,HiLo,ReturnStr);
       SetKbd(Lock);
     end;

  Begin
    Lock:=SaveKbd;
    SetKbd(NumOn);
    SetUp;
    Repeat
      Repeat
        Key:=KeyWait;
      Until (Key in ValidNum);
      Resp:=chr(Key);
      pos:=pos+1;
      Case Key of
        EnterKey  : if pos>0              { Return Key -- Complete }
                      then pos:=len;
        EscapeKey : Setup;                { Escape Key -- Restart }
        MinusSign : if ReturnStr[len]=chr(NumerPrmt)
                      then Add_Next;      { Minus -- First chr only }
        DecimalPt : if decimal=false      { Decimal -- one only }
                      then begin
                             Add_Next;
                             decimal:=true;
                           end
                      else pos:=pos-1;
        else Add_Next;                    { Digits 0..9 -- Accept }
      end; { Case }
    Until (pos=len);
    Exit;
  End;
  { ** NumInput ** }

Procedure AlphaInput{**( col,row,len : Byte;
                        HiLo : DspAtt;
                        var ReturnStr : AnyStr)**};

  var   pos,Lock,Key  : Byte;
        Resp          : Char;

  procedure SetUp;
    begin
      pos:=0;
      ReturnStr:=Stringof(AlphaPrmt,len);
      WriteAt(col,row,h,ReturnStr);
    end;

  procedure Add_Next;
    begin
      ReturnStr[pos]:=Resp;
      WriteAt(col,row,h,ReturnStr);
    end;

  procedure Moveback;
    begin
      ReturnStr[pos-1]:=chr(AlphaPrmt);
      WriteAt(col,row,h,ReturnStr);
      pos:=pos-2;
    end;

  procedure Exit;
    begin
      While ReturnStr[pos]=chr(AlphaPrmt) do
        begin
          ReturnStr[pos]:=' ';
          pos:=pos-1;
        end;
      WriteAt(col,row,HiLo,ReturnStr);
      SetKbd(Lock);
    end;

  Begin
    SetUp;
    Lock:=SaveKbd;
    SetKbd(NumOn);
    Repeat
      Repeat
        Key:=KeyWait;
      Until (Key in ValidAlpha);
      Resp:=chr(Key);
      pos:=pos+1;
      Case Key of
        Backspace  : if pos>2
                       then Moveback      { destructive Backspace }
                       else SetUp;
        EnterKey   : if pos>0             { Return Key -- Complete }
                       then pos:=len;
        EscapeKey  : Setup;               { Escape Key -- Restart }
        else Add_Next;                    { Valid Entry -- Accept }
      end; { Case }
    Until (pos=len);
    Exit;
  End;
  { ** AlphaInput ** }